home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 027a / clipio.zip / BLAKGLOB.PRG < prev    next >
Text File  |  1990-06-23  |  9KB  |  327 lines
  1. *-----------------------------------HELPBAR------------------------------------*40
  2.  
  3. function helpbar
  4. parameters options, keys
  5.  
  6. private lcv, count, col
  7.  
  8. * begin
  9.     vpushscrn(24, 0, 24, 79)
  10.     vfillchar(24, 0, 24, 79, 32)
  11.     count = len(options)
  12.     col = 1
  13.     for lcv = 1 to count
  14.         vputstrc(24, col, keys[lcv], _c_hlpk)
  15.         col = col + len(keys[lcv])
  16.         vputstrc(24, col, options[lcv], _c_help)
  17.         col = col + len(options[lcv]) + 2
  18.     next lcv
  19. return ''
  20.  
  21. *-----------------------------------PROMPT-------------------------------------*
  22.  
  23. function prompt
  24. parameters ulr, ulc, message, pop, ans0, ans1, ans2, ans3, ans4, ans5, ans6, ans7, ans8, ans9
  25.  
  26. private retval, anscount, answers, length, width, lrr, lrc,;
  27.         messlen, nc, mlength, lcv, col, anykey
  28.  
  29. * begin
  30.     if pcount() < 3
  31.         misc_error(procname(), procline(), 'too few parameters')
  32.     elseif pcount() > 14
  33.         misc_error(procname(), procline(), 'too many parameters')
  34.     endif
  35.     if pcount() < 4
  36.         pop = .t.
  37.     endif
  38.     anscount = pcount() - 4
  39.     if (anscount = 0) .and. pop
  40.         anscount = 1
  41.         ans0 = 'Ok'
  42.         anykey = .t.
  43.     else
  44.         anykey = .f.
  45.     endif
  46.     messlen = if(len(message) > 76, 76, len(message))
  47.     answers = ''
  48.     bwidth = 0
  49.     for lcv = 1 to anscount
  50.         nc = chr(lcv + 47)
  51.         answers = answers + upper(left(ans&nc, 1))
  52.         bwidth = bwidth + 4 + len(ans&nc)
  53.     next lcv
  54.     width = if(messlen > bwidth, messlen, bwidth)
  55.     mlength = mlcount(message, 76, 4, .t.)
  56.     length = mlength + if(anscount > 0, 3, 0)
  57.     if ulr < 0
  58.         if row() > 12
  59.             ulr = (row() - length - 2) / 2
  60.         else
  61.             ulr = ((23 - row() - length) / 2) + row()
  62.         endif
  63.         if (ulr < 0) .or. (ulr + length + 2 > 25)
  64.             ulr = (23 - length) / 2
  65.         endif
  66.     endif
  67.     if ulc < 0
  68.         ulc = (76 - width) / 2
  69.     endif
  70.     lrr = ulr + length + 1
  71.     lrc = ulc + width + 3
  72.     oldctrl = msavectrl(ulr, ulc, lrr, lrc)
  73.     mdefctrl(ulr, ulc, lrr, lrc, 255)
  74.     vpushstate()
  75.     vsetcolor(_c_wind_st, _c_wind_en, _c_wind_un)
  76.     vpushscrn(ulr, ulc, lrr, lrc)
  77.     @ ulr, ulc to lrr, lrc
  78.     vfillattr(ulr, ulc, lrr, lrc, vsetstan())
  79.     vfillchar(ulr+1, ulc+1, lrr-1, lrc-1, 32)
  80.     if messlen = 76
  81.         for lcv = 1 to mlength
  82.             vputstr(ulr + lcv, ulc + 2, memoline(message, 76, lcv))
  83.         next lcv
  84.         vmovecurs(ulr + mlength, ulc + 2 + len(trim(memoline(message, 76, mlength))))
  85.     else
  86.         vputstr(ulr + 1, ((width - messlen) / 2) + ulc + 2, message)
  87.         vmovecurs(ulr + 1, ((width - messlen) / 2) + ulc + 2 + len(message))
  88.     endif
  89.     col = ((width - bwidth) / 2) + ulc + 2
  90.     for lcv = 1 to anscount
  91.         nc = chr(lcv + 47)
  92.         @ ulr + mlength + 1, col to ulr + mlength + 3, col + 3 + len(ans&nc)
  93.         mdefctrl(ulr + mlength + 1, col, ulr + mlength + 3, col + 3 + len(ans&nc), lcv)
  94.         vputstr(ulr + mlength + 2, col + 2, ans&nc)
  95.         vputstrc(ulr + mlength + 2, col + 2, left(ans&nc, 1), if(!iscolor(), _c_wind_un, int(_c_wind_en / 16) + _c_wind_st  - (_c_wind_st % 16)))
  96.         col = col + len(ans&nc) + 4
  97.     next lcv
  98.     retval = ''
  99.     if pop
  100.         mpushstate()
  101.         do while len(retval) = 0
  102.             kp = keygetup()
  103.             if anykey .and. (kp <> -131)
  104.                 retval = chr(kp)
  105.             elseif (kp = -131) .and. (mgetbutton() = 'L ') .and. (mgetctrl() < 255)
  106.                 retval = substr(answers, mgetctrl(), 1)
  107.             elseif chr(kp) $ answers
  108.                 retval = chr(kp)
  109.             endif
  110.         enddo
  111.         mpopstate()
  112.         vpopscrn()
  113.     endif
  114.     mrestctrl(ulr, ulc, lrr, lrc, oldctrl)
  115.     vpopstate()
  116. return retval
  117.  
  118. *------------------------------------PAD---------------------------------------*
  119.  
  120. function pad
  121. parameters init_val, length
  122.  
  123. * begin
  124. return substr(init_val + space(length), 1, length)
  125.  
  126. *-----------------------------------CENTER-------------------------------------*
  127.  
  128. function center
  129. parameters init_val, length
  130.  
  131. private half
  132.  
  133. * begin
  134.     half = length - len(init_val)
  135.     if (half % 2 = 1) .and. (half > 0)
  136.         init_val = ' ' + init_val
  137.         half = half - 1
  138.     endif
  139. return space(half/2) + init_val + space(half/2)
  140.  
  141. *---------------------------------UNPICTURE------------------------------------*
  142.  
  143. function unpicture
  144. parameters string, picture
  145.  
  146. private ret_val, length, ptr
  147.  
  148. * begin
  149.     ret_val = ''
  150.     length = min(len(string), len(picture))
  151.     for ptr = 1 to length
  152.         if (upper(substr(picture, ptr, 1)) $ 'ANX9#LY!')
  153.             ret_val = ret_val + substr(string, ptr, 1)
  154.         endif
  155.     next ptr
  156.     ret_val = ret_val + substr(string, length+1, len(string))
  157. return ret_val
  158.  
  159. *----------------------------------INC_UNIQ------------------------------------*
  160.  
  161. function inc_uniq
  162. parameters uniq
  163.  
  164. * begin
  165.     carry = .t.
  166.     pos = 4
  167.     do while (pos >= 1) .and. carry
  168.         carry = (substr(uniq, pos, 1) = chr(255))
  169.         uniq = substr(uniq, 1, pos - 1) +;
  170.             if(carry, chr(1), chr(asc(substr(uniq, pos, 1)) + 1)) +;
  171.             substr(uniq, pos + 1, len(uniq))
  172.         pos = pos - 1
  173.     enddo
  174. return uniq
  175.  
  176. *----------------------------------RPT_COLUMNS---------------------------------*
  177.  
  178. function rpt_columns
  179. parameters columns, lengths
  180.  
  181. private ret_val, lcv, length
  182.  
  183. * begin
  184.     ret_val = ''
  185.     length = len(columns)
  186.  
  187.     for lcv = 1 to length-1
  188.         ret_val = ret_val + center(columns[lcv], lengths[lcv]) + ' '
  189.     next lcv
  190.  
  191.     ret_val = ret_val + center(columns[length], lengths[length])
  192.  
  193. return ret_val
  194.  
  195. *-------------------------------RPT_UNDERLINE----------------------------------*
  196.  
  197. function rpt_underline
  198. parameters lengths
  199.  
  200. private ret_val, lcv, length
  201.  
  202. * begin
  203.     ret_val = ''
  204.     length = len(lengths)
  205.  
  206.     for lcv = 1 to length-1
  207.         ret_val = ret_val + replicate('_', lengths[lcv]) + ' '
  208.     next lcv
  209.  
  210.     ret_val = ret_val + replicate('_', lengths[length])
  211. return ret_val
  212.  
  213. *----------------------------------RPT_LINE------------------------------------*
  214.  
  215. function rpt_line
  216. parameters fields, lengths
  217.  
  218. private ret_val, lcv, command, length
  219.  
  220. * begin
  221.     ret_val = ''
  222.     length = len(fields)
  223.  
  224.     for lcv = 1 to length-1
  225.         command = fields[lcv]
  226.         ret_val = ret_val + pad(&command, lengths[lcv]) + ' '
  227.     next lcv
  228.  
  229.     command = fields[length]
  230.     ret_val = ret_val + pad(&command, lengths[length])
  231. return ret_val
  232.  
  233. *----------------------------------GET_KEY-------------------------------------*
  234.  
  235. function get_key
  236.  
  237. private ret_val
  238.  
  239. * begin
  240.     ret_val = indexkey(0)
  241. return &ret_val
  242.  
  243. *------------------------------------MPIC--------------------------------------*
  244.  
  245. function mpic
  246. parameters var, pic
  247.  
  248. * begin
  249.     if pcount() < 2
  250.         pic = ''
  251.     endif
  252.     mdefctrl(row(), col(), row(), col() + len(transform(var, pic)), piccount)
  253.     piccount = piccount + 1
  254. return pic
  255.  
  256. *----------------------------------FINDCLICK-----------------------------------*
  257.  
  258. function findclick
  259. parameters callprog, linenum, inputvar
  260.  
  261. private ctrl, lcv, key
  262.  
  263. * begin
  264.     if (mgetbutton() == 'L ') .and. (mgetctrl() > 0) .and. (mgetctrl() < 32)
  265.         ctrl = mgetctrl() - mgetctrl(row(), col()-1)
  266.         if ctrl < 0
  267.             key = -72
  268.             ctrl = -ctrl
  269.         else
  270.             key = -80
  271.         endif
  272.         for lcv = 1 to ctrl
  273.             keyinsert(key)
  274.         next lcv
  275.     endif
  276. return ''
  277.  
  278. *--------------------------------BLAKDIAL--------------------------------------*
  279.  
  280. function blakdial
  281. parameters callprog, linenum, inputvar
  282.  
  283. private dialstr, local
  284.  
  285. * begin
  286.     if (substr(PHONE, 2, 3) == _areacode)
  287.         dialstr = trim(_localpre) + substr(PHONE, 6, 8) + trim(_localsuf)
  288.     else
  289.         dialstr = trim(_longpre) + PHONE + trim(_longsuf)
  290.     endif
  291.     prompt(12, -1, 'Dialing ' + dialstr + '.  Please wait...', .f.)
  292.     fwrite(fopen(_comport, 1), 'atdt' + dialstr + chr(13))
  293.     tone(0, 5)
  294.     vpopscrn()
  295.     prompt(12, -1, 'Pick up receiver and press any key...', .t.)
  296.     fwrite(fopen(_comport, 1), 'ath')
  297.     longtimer()
  298. return ''
  299.  
  300. *--------------------------------LONGTIMER-------------------------------------*
  301.  
  302. function longtimer
  303.  
  304. private t0, row, et, minutes
  305.  
  306. * begin
  307.     t0 = seconds()
  308.     prompt(-1, -1, 'Length of this call     minutes    seconds.  Press any key to stop timer...', .f.)
  309.     row = row()
  310.     do while (inkey(.1) = 0)
  311.         et = round(seconds() - t0, 0)
  312.         minutes = int(et/60)
  313.         vputstr(row, 22, str( minutes, 3, 0 ))
  314.         vputstr(row, 34, str( et - (minutes * 60), 2, 0))
  315.     enddo
  316.     vpopscrn()
  317. return ''
  318.  
  319. *--------------------------------FREE_MEMORY-----------------------------------*
  320.  
  321. procedure Free_Memory
  322. parameters callprog, linenum, inputvar
  323.  
  324. * begin
  325.     prompt(-1, -1, 'Free Memory: ' + ltrim(str(memory(0))) + 'K', .t.)
  326. return
  327.